COMMENT ⊗   VALID 00008 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	ENTRY
C00003 00003	! copycall,editcall
C00005 00004	! 	readcall,renmcall,writecall
C00008 00005	! display: update,arrow,displaycall,redisplaycall,showcall,nodisplaycall
C00014 00006	!	graphcall
C00015 00007	!	deletecall,definecall,notavailcall,exitcall
C00021 00008	!	bailcall,setstatuscall,readmesscall,stopmesscall
C00025 ENDMK
C⊗;
ENTRY;
BEGIN "PCALL"
COMMENT routines which are not available in AL;
DEFINE $PCALL=TRUE,$ALTER_EGO=TRUE;
REQUIRE "HEADER.SAI" SOURCE_FILE;
! copycall,editcall;

	! parses the instructions
		MERGE <frame_id> INTO <frame_id>
		COPY  <frame_id> INTO <frame_id>
	  First is MERGE or COPY;
	! MERGE <frame_id> is now COPY SUBTREE(<frame_id>) ;

INTERNAL PROCEDURE COPYCALL;
	BEGIN
	STRING FR1,FR2,FIRST;
	$HELP←14;
	GTOKEN;
	IF EQU(TOKEN,"SUBTREE") THEN
		BEGIN
		 WORD_READ("("); FR1←IDF_READ;
		 WORD_READ(")"); FIRST←"MERGE";
		END
		ELSE
		BEGIN
		STOKEN←TRUE;
		FR1←IDF_READ;				! reads first frame;
		FIRST←"COPY";
		END;
	WORD_READ("INTO"); 				! reads INTO;
	FR2←IDF_READ;   			! reads second frame;
	SEMICOL_READ; 
	COPYCODE(FIRST,FR1,FR2);
	END;

INTERNAL PROCEDURE EDITCALL(STRING WHAT);
	BEGIN
	STRING VAR;
	NOEXPAND←TRUE;
	IF EQU(WHAT,"EDIT")THEN $HELP←37 ELSE $HELP←38;
	VAR←IDF_READ; 
	SEMICOL_READ;    
	IF EQU(WHAT,"EDIT") THEN EDITCODE(VAR)ELSE RENMCODE(VAR);
	END;
! 	readcall,renmcall,writecall;

IFC #OUTPT THENC
	
INTERNAL PROCEDURE READCALL(BOOLEAN ECHO(TRUE));
	BEGIN
	STRING FILE;           
	IF $COMPILE≠0 THEN ERROR("READ: cannot be inside a block");
	$HELP←34;
	FILE←"DECLAR.AL";				! default value;
	NOEXPAND←TRUE;
	GTOKEN(FALSE);
	IF NOT FINAL
	   THEN BEGIN
		STOKEN←TRUE;FILE←NAMEFILE;SEMICOL_READ;
		END;
	NOEXPAND←FALSE;
        READCODE(FILE,ECHO);
	END;

INTERNAL PROCEDURE WRITCALL;
	BEGIN "A"
	STRING FILE;
	INTEGER NELEMENTS,I;
	RPTR(SYMBOL)ARRAY ELEMENTS[1:20];
	IF $COMPILE≠0 THEN ERROR("WRITE: cannot be inside a block");

	NELEMENTS←0;
	$HELP←31;
	NOEXPAND←TRUE;			! to let through macro names ;
	FILE←$ALFL;			! default values;
	GTOKEN(FALSE);
	IF NOT FINAL 
	   THEN CASE #TOKEN OF
		α	
		[RES_TYPE]
			IF EQU(TOKEN,"INTO") THEN STOKEN←TRUE
			  ELSE IF ¬EQU(TOKEN,"ALL") THEN ERROR("Can't use "&TOKEN&
				" as argument to be saved in a write statement");
		[ID_TYPE]
			DO α
			IF (NELEMENTS←NELEMENTS+1)>21 THEN ERROR("Cant output more than 21 elements in one statement");
			ELEMENTS[NELEMENTS]←TOKENPTR;
			GTOKEN(FALSE);
			IF TOKEN="," THEN GTOKEN
			    ELSE IF FINAL THEN DONE
				ELSE STOKEN←TRUE;
			β UNTIL #TOKEN≠ID_TYPE;

		ELSE ERROR("Can't write out the value of "&TOKEN)
		β;
	GTOKEN(FALSE);
	IF NOT FINAL
	    THEN IF ¬EQU(TOKEN,"INTO") THEN
			ERROR("Need INTO here before putting in file name, but you have got "&token)
		  ELSE FILE←NAMEFILE;
	SEMICOL_READ;
	IF NELEMENTS=0 THEN WRITECODE(FILE,NULL_RECORD)
	    ELSE FOR I←1 STEP 1 UNTIL NELEMENTS DO WRITECODE(FILE,ELEMENTS[I]);

	NOEXPAND ← FALSE;
	END "A";
ENDC
! display: update,arrow,displaycall,redisplaycall,showcall,nodisplaycall;
IFC ¬ #ARROW THENC
INTERNAL SIMPLE PROCEDURE ARROW; ;
ENDC
IFC #DISPL THENC

INTEGER MDISPLAY; ! display mode;
DEFINE  TABLE_DISPLAY=0,
	TYPE_DISPLAY=1,
	SYMBOL_DISPLAY=2,
	NO_DISPLAY=3;

SIMPLE  STRING PROCEDURE DEFAULT;
	RETURN(" "&OLDCMD&CRLF&" "&OLDOBJ&CRLF);

RCLASS SYMBOL_LIST(RPTR(SYMBOL_LIST)NEXT;RPTR(SYMBOL)PTR);
RPTR(SYMBOL_LIST) DISPLAY_LIST;

INTEGER TDISPLAY;
BOOLEAN NDISPLAY;
PROCEDURE DPYELM(STRING S);
	OUTDPW(
"########################### SELECTED VARIABLES ############################"
&crlf&S&crlf&
"###########################################################################",
-3,-2);

PROCEDURE DPYVAR(INTEGER VARTYPE);
	IF NOT $DISPLAYLIST[VARTYPE] THEN
		OUTDPW(
("************************* CURRENT "&$DTYPE[VARTYPE]&"S ***********************************************")
[1 TO 74]&crlf&($DISPLAYLIST[VARTYPE]←DPY_STRING(VARTYPE))&
"***************************************************************************"
,-3,-3);

PROCEDURE DPYSYMS;
BEGIN STRING S;
	RPTR(SYMBOL)SYM;
	RPTR(SYMBOL_LIST)SYL;
	SYL←DISPLAY_LIST;
	S←NULL;
	WHILE SYL≠NULL_RECORD
		DO BEGIN
		S←S&CVSSYM(SYMBOL_LIST:PTR[SYL])&CRLF;
		SYL←SYMBOL_LIST:NEXT[SYL];
		END;
	DPYELM(S);
END;

	! update the display (if $ALLOW=0);

INTERNAL PROCEDURE UPDATE;
	BEGIN INTEGER I;
 	IF $ALLOW>0 THEN RETURN;
	CASE MDISPLAY OF
	    BEGIN
	    [TABLE_DISPLAY]
		BEGIN
		DPYDRAW;
		FOR I←#SC,#VT,#TR,#RT,#FR DO
			IF NOT $DISPLAYLIST[I] THEN $DISPLAYLIST[I]←DPY_STRING(I);
		IFC #OUTPT THENC IF NOT $OULST THEN $OULST←FILE_STRING;ENDC
		$DFLST←DEFAULT;
		OUTDPY;
	 	DPYOUT(1);
		END;
	    [NO_DISPLAY]
		IF NDISPLAY THEN
		BEGIN
		 OUTDPW(
"**************************** P O I N T Y **********************************
DISPLAY SUPPRESSED; TYPE   REDISPLAY  TO GET BACK DISPLAY TABLE
TYPE  DISPLAY SCALARS  TO DISPLAY SCALARS
****************************************************************************
",-3,-2); NDISPLAY←FALSE;
		END;
	    [TYPE_DISPLAY]
		DPYVAR(TDISPLAY);
	    [SYMBOL_DISPLAY]
		DPYSYMS
	    END;
	    ESC_P;
	END;
ENDC

IFC #DISPL THENC

INTERNAL PROCEDURE REDISPLAYCALL;
	BEGIN
	SEMICOL_READ;
	$ALLOW←0;
	TDISPLAY←0;
	MDISPLAY←TABLE_DISPLAY;
	DISPLAY_LIST←NULL_RECORD;
	$SCLST←NULL;
	END;

INTERNAL PROCEDURE NODISPLAYCALL;
	BEGIN
	! SUPPRESS DISPLAY;
	SEMICOL_READ;
	NDISPLAY←TRUE;
	MDISPLAY←NO_DISPLAY;
	DISPLAY_LIST←NULL_RECORD;
	END;

INTERNAL PROCEDURE DISPLAYCALL;
	BEGIN
	INTEGER TT;
	NOEXPAND ← TRUE;
	GTOKEN;
	IF TOKENPTR ≠ NULL_RECORD
	THEN DPYELM(CVSSYM(TOKENPTR))
	ELSE BEGIN
		FOR TT←#MIN STEP 1 UNTIL #MAX DO
		   IF EQU(TOKEN,$DTYPE[TT]) OR EQU(TOKEN,$DTYPE[TT]&"S") THEN DONE;
		IF TT≤#MAX THEN $DISPLAYLIST[TT]←NULL
		   ELSE ERROR("No such data type or identifier: "&TOKEN&CRLF);
		SEMICOL_READ;
		MDISPLAY←TYPE_DISPLAY;
		TDISPLAY←TT;
	    END;
	NOEXPAND ← FALSE;
	END;

INTERNAL PROCEDURE SHOWCALL;
	BEGIN
	RPTR(SYMBOL_LIST)SL1,SL2;
	NOEXPAND ← TRUE;
	SL1←SL2←NEW_RECORD(SYMBOL_LIST);
	DO BEGIN
	    GTOKEN;
	    IF TOKENPTR=NULL_RECORD
		THEN ERROR("SHOW: Need a macro, procedure or variable name after SHOW");
	    SYMBOL_LIST:NEXT[SL2]←SL2←NEW_RECORD(SYMBOL_LIST);
	    SYMBOL_LIST:PTR[SL2]←TOKENPTR;
	    GTOKEN(FALSE);
	    IF TOKEN≠"," AND NOT FINAL THEN ERROR("Need a comma to separate arguments");
	   END UNTIL FINAL;
	NOEXPAND ← FALSE;
	MDISPLAY←SYMBOL_DISPLAY;
	DISPLAY_LIST←SYMBOL_LIST:NEXT[SL1];
	END;
ENDC


!	graphcall;
IFC #GATHER THENC
INTERNAL PROCEDURE GRAPHCALL;
BEGIN
	IF $COMPILE≠0 THEN ERROR("GRAPH: can only be called outside a block");
	IF GRAPTR=NULL_RECORD THEN ERROR("GRAPH: no data currently available");
	BRK_N;
	GRAPH(GRAPHREC:DATA[GRAPTR],
			GRAPHREC:CTLBITS[GRAPTR],
			GRAPHREC:NPNTS[GRAPTR],
			GRAPHREC:SIZE[GRAPTR]);
	GRAPTR←NULL_RECORD;
END;

ENDC
!	deletecall,definecall,notavailcall,exitcall;

INTERNAL PROCEDURE DELETECALL(BOOLEAN QUIET(FALSE));
	BEGIN
	STRING VAR;
	IF $COMPILE≠0 THEN ERROR("DELETE: cannot be invoked inside a block or procedure");

	NOEXPAND ← TRUE;
	GTOKEN(FALSE);
	IF FINAL OR EQU(TOKEN,"ALL")
	   THEN IF QUIET OR EQU(TOKEN,"ALL") THEN RESET
		ELSE  BEGIN	! deletes all the variables;
		STRING ANSWER;
		PRINT("are you sure all variables are to be deleted? ");
		ANSWER←INCHRW;
		PRINT(CRLF);ESC_P;
		IF ANSWER="Y" OR ANSWER="y"
		   THEN	RESET
		   ELSE ABORT1($SEMSG[13]);
		END
	   ELSE BEGIN
		STOKEN←TRUE;
		$ALLOW←$ALLOW+1;
		DO BEGIN "A"
			VAR←IDF_READ;
			KILLVAR(TOKEN,QUIET);
			GTOKEN(FALSE);
			IF TOKEN≠"," AND NOT FINAL
			   THEN BEGIN
			   PRINT($SYNMSG[0],$SYNMSG[25]," OR ");
		           ERROR($SYNMSG[1],$SYNMSG[25] );
		     	   END;
		   END "A"
		UNTIL FINAL;
		$ALLOW←$ALLOW-1;
		END;
	NOEXPAND ← FALSE;
	END;


INTERNAL PROCEDURE DEFINECALL;
   BEGIN RPTR(MACRO) MACPTR; STRING MACNAME; INTEGER DDLCOUNT; STRING BODY,NBODY;
	INTEGER NPARAM;
	NPARAM←0;
	NOEXPAND ← TRUE;
	GTOKEN;
	IF #TOKEN ≠ UNDECLARED_TYPE
		THEN ERROR("MACRO DEFINITION: need undeclared identifier");
	DDLCOUNT ← 0;
	MACPTR ← NEW!RECORD(MACRO);
	MACNAME ← TOKEN;
	GTOKEN;

	IF TOKEN≠"("
	   THEN BEGIN STOKEN←TRUE; MACRO:HEAD[MACPTR]←MACNAME; END
	   ELSE
	    BEGIN "parametered macro"
		RCLASS PLIST(STRING PARAM; RPTR(PLIST) NEXTP);
	    	RPTR(PLIST) TEMP,TEMP0;
		TEMP0←NULL_RECORD;
		DO
		BEGIN "get parameters"
		GTOKEN;
		IF #TOKEN ≠ UNDECLARED_TYPE THEN 
		    ERROR("MACRO DEFINITION: need undeclared token for argument");
		NPARAM←NPARAM+1;
		TEMP←NEW!RECORD(PLIST);
		PLIST:NEXTP[TEMP]←TEMP0;
		PLIST:PARAM[TEMP]←TOKEN;
		TEMP0←TEMP;
		GTOKEN;
		IF TOKEN≠")" AND TOKEN≠"," 
		    THEN ERROR("MACRO DEFINITION: Need comma here");
		END "get parameters" UNTIL TOKEN=")";

		BEGIN
		INTEGER I; STRING ARRAY S[1:NPARAM];
		STRING HEAD; HEAD←")";

		FOR I←NPARAM STEP -1 UNTIL 1 DO
			BEGIN
			HEAD←","&(S[I]←PLIST:PARAM[TEMP])&HEAD;
			TEMP←PLIST:NEXTP[TEMP];
			END;
		MEMORY[LOCATION(S)]↔MEMORY[LOCATION(MACRO:PRLIST[MACPTR])];
		MACRO:HEAD[MACPTR]←MACNAME&"("&HEAD[2 TO ∞];
		END;
		MACRO:NPARAM[MACPTR]←NPARAM;
	    END "parametered macro";
	WORD_READ("=");
	WORD_READ("⊂"); DDLCOUNT ← 1;
	BODY←"⊂";
	
	DO BEGIN
		INTEGER I;
		I←READTILL("⊂⊃");
		BODY←BODY&TOKEN&I;
		IF I="⊂"
		   THEN DDLCOUNT ← DDLCOUNT + 1
		   ELSE DDLCOUNT ← DDLCOUNT - 1;
	   END UNTIL DDLCOUNT=0;

	BODY←BODY[2 TO ∞-1];
	IF NPARAM>0 THEN
	BEGIN
	NBODY←NULL;
	WHILE BODY DO
		BEGIN "process the parameters"
		INTEGER I;
		INTEGER BRCHAR; STRING TTOKEN;
		NBODY←NBODY&SCAN(BODY,$LTTAB,BRCHAR);
		TTOKEN←SCAN(BODY,$NLTTAB,BRCHAR);
		FOR I←1 STEP 1 UNTIL NPARAM
		    DO	IF EQU(MACRO:PRLIST[MACPTR][I],TTOKEN) THEN DONE;
		IF I>NPARAM THEN
			NBODY←NBODY&TTOKEN
			ELSE NBODY←NBODY&DUMMY_DELIM&TTOKEN&DUMMY_DELIM;
		END "process the parameters";
	END ELSE NBODY←BODY;
	MACRO:BODY[MACPTR]←NBODY;
	SEMICOL_READ;
	ENSYM(MACNAME, #MC, MACPTR);
	NOEXPAND ← FALSE;
	$MCLST←NULL;
   END;

INTERNAL PROCEDURE NOTAVAILCALL;
	BEGIN
	PRINT(TOKEN & " " &#VERSION);
	OUTSTR("Will flush this statement"&crlf);
	DO GTOKEN(FALSE) UNTIL FINAL;
	END;

INTERNAL PROCEDURE EXITCALL;
	BEGIN 
	SEMICOL_READ;
	ENDIT;
	END;

!	bailcall,setstatuscall,readmesscall,stopmesscall;

INTERNAL PROCEDURE BAILCALL;
	BAILCODE;
INTERNAL PROCEDURE QBLCALL;
	QBAILCODE;

INTERNAL PROCEDURE SETSTATUSCALL;
	BEGIN
	! this procedure is to set the values of certain POINTY system variables
	in the SAIL part for program control : it takes a VARIABLE and an integer
	and assigns the value of the string to the variable name ;
	INTEGER VARVALUE,I; STRING VARNAME;
	WORD_READ("(");
	NOEXPAND←TRUE;
	GTOKEN;
	VARNAME←TOKEN;
	WORD_READ(",");
	GTOKEN;
	IF #TOKEN≠INT_TYPE THEN ERROR("SETSTATUS: Need integer argument");
	VARVALUE←INTSCAN(TOKEN,I);
	IF EQU(VARNAME,"PPCODE") THEN !PPCODE←VARVALUE
		ELSE IF EQU(VARNAME,"LINE") THEN !LINE←VARVALUE;
	GTOKEN;
	IF TOKEN≠")" THEN ERROR("SETSTATUS: need )");
	NOEXPAND←FALSE;
	SEMICOL_READ;
	END;

INTERNAL PROCEDURE READMESSCALL;
	BEGIN
	SEMICOL_READ;
	PUSHDEVSTACK;
	DEVICE←MESSAGE_X;
	END;

INTERNAL PROCEDURE STOPMESSCALL;
	BEGIN
	SEMICOL_READ;
	$CLNE←$CLINR←NULL;
	POPDEVSTACK;
	END;

END "PCALL";